unit WinIcmp;

interface

uses
  Windows,
  Classes,
  SysUtils;

const
  // IP_STATUS codes returned from IP APIs

  IP_STATUS_BASE = 11000;
  IP_SUCCESS = 0;
  IP_BUF_TOO_SMALL = (IP_STATUS_BASE + 1);
  IP_DEST_NET_UNREACHABLE = (IP_STATUS_BASE + 2);
  IP_DEST_HOST_UNREACHABLE = (IP_STATUS_BASE + 3);
  IP_DEST_PROT_UNREACHABLE = (IP_STATUS_BASE + 4);
  IP_DEST_PORT_UNREACHABLE = (IP_STATUS_BASE + 5);
  IP_NO_RESOURCES = (IP_STATUS_BASE + 6);
  IP_BAD_OPTION = (IP_STATUS_BASE + 7);
  IP_HW_ERROR = (IP_STATUS_BASE + 8);
  IP_PACKET_TOO_BIG = (IP_STATUS_BASE + 9);
  IP_REQ_TIMED_OUT = (IP_STATUS_BASE + 10);
  IP_BAD_REQ = (IP_STATUS_BASE + 11);
  IP_BAD_ROUTE = (IP_STATUS_BASE + 12);
  IP_TTL_EXPIRED_TRANSIT = (IP_STATUS_BASE + 13);
  IP_TTL_EXPIRED_REASSEM = (IP_STATUS_BASE + 14);
  IP_PARAM_PROBLEM = (IP_STATUS_BASE + 15);
  IP_SOURCE_QUENCH = (IP_STATUS_BASE + 16);
  IP_OPTION_TOO_BIG = (IP_STATUS_BASE + 17);
  IP_BAD_DESTINATION = (IP_STATUS_BASE + 18);

  // The next group are status codes passed up on status indications to
  // transport layer protocols.
  IP_ADDR_DELETED = (IP_STATUS_BASE + 19);
  IP_SPEC_MTU_CHANGE = (IP_STATUS_BASE + 20);
  IP_MTU_CHANGE = (IP_STATUS_BASE + 21);
  IP_UNLOAD = (IP_STATUS_BASE + 22);
  IP_GENERAL_FAILURE = (IP_STATUS_BASE + 50);
  MAX_IP_STATUS = IP_GENERAL_FAILURE;
  IP_PENDING = (IP_STATUS_BASE + 255);

  // Values used in the IP header Flags field.
  IP_FLAG_DF = $2; // Don't fragment this packet.

  // Supported IP Option Types.
  // These types define the Options which may be used in the OptionsData field
  // of the ip_option_information structure. See RFC 791 for a complete
  // description of each.
  IP_OPT_EOL = 0; // End of list option
  IP_OPT_NOP = 1; // No operation
  IP_OPT_SECURITY = $82; // Security option
  IP_OPT_LSRR = $83; // Loose source route
  IP_OPT_SSRR = $89; // Strict source route
  IP_OPT_RR = $7; // Record route
  IP_OPT_TS = $44; // Timestamp
  IP_OPT_SID = $88; // Stream ID (obsolete)

  MAX_OPT_SIZE = 40; // Maximum length of IP Options in bytes

  INADDR_NONE: Integer = -1;

type

  TIPAddr = Integer; // An IP address.
  TIPMask = Integer; // An IP subnet mask.
  TIP_STATUS = Integer; // Status code returned from IP APIs.

  POption_Information = ^TOption_Information;

  TOption_Information = record
    Ttl: Byte; // Time To Live
    Tos: Byte; // Type Of Service
    Flags: Byte; // IP header flags
    OptionsSize: Byte; // Size in bytes of Options data
    OptionsData: Pointer; // Pointer to Options data
  end;

  Picmp_echo_reply = ^Ticmp_echo_reply;

  Ticmp_echo_reply = record
    Address: TIPAddr; // Replying address
    Status: Integer; // Reply IP_STATUS
    RoundTripTime: Integer; // RTT in milliseconds
    DataSize: Word; // Reply data size in bytes
    Reserved: Word; // Reserved for system use
    Data: Pointer; // Pointer to the reply data
    Options: TOption_Information; // Reply Options
  end;

  TsmICMP_Echo_Reply = record
    Address: TIPAddr; // Replying address
    Status: Integer; // Reply IP_STATUS
    RoundTripTime: Integer; // RTT in milliseconds
    DataSize: Word; // Reply data size in bytes
    Reserved: Word; // Reserved for system use
    DataPtr: Pointer; // Pointer to the reply data
    Options: TOption_Information; // Reply Options
    Data: array[0..255] of Char;
  end;

function IcmpCreateFile: THandle; stdcall;
function IcmpCloseHandle(H: THandle): Bool; stdcall;
function IcmpSendEcho(IcmpHandle: THandle; DestinationAddress: TIPAddr;
  RequestData: Pointer; RequestSize: Word;
  RequestOptions: POption_Information; ReplyBuffer: Pointer;
  ReplySize: Integer; TimeOut: Integer): Integer; stdcall;

procedure Ping(const Address, EchoString: PChar; var PingReply: TsmICMP_Echo_Reply;
  const PingTimeout: Integer = 500);
function PingStatusToStr(StatusCode: Integer): string;
function inet_addr(IPAddress: PChar): TIPAddr; stdcall;

implementation

function IcmpCreateFile; external 'Icmp.Dll';
function IcmpCloseHandle; external 'Icmp.Dll';
function IcmpSendEcho; external 'Icmp.Dll';

procedure Ping(const Address, EchoString: PChar; var PingReply: TsmICMP_Echo_Reply; const PingTimeout: Integer = 500);
var
  IPAddress: TIPAddr;
  ICMPPort: THandle;
begin
  IPAddress := inet_addr(Address);
  if (IPAddress = INADDR_NONE) then
  begin
    raise Exception.Create('Function call inet_addr failed. The IP address is probably invalid.');
  end;
  ICMPPort := IcmpCreateFile();
  if (ICMPPort = INVALID_HANDLE_VALUE) then
  begin
    raise Exception.Create('Function call IcmpCreateFile failed.');
  end;
  IcmpSendEcho(ICMPPort, IPAddress, EchoString, Length(EchoString), nil, @PingReply, SizeOf(PingReply), PingTimeout);
  IcmpCloseHandle(ICMPPort);
end;

function PingStatusToStr(StatusCode: Integer): string;
begin
  case (StatusCode) of
    IP_SUCCESS: Result := 'IP_SUCCESS';
    IP_BUF_TOO_SMALL: Result := 'IP_BUF_TOO_SMALL';
    IP_DEST_NET_UNREACHABLE: Result := 'IP_DEST_NET_UNREACHABLE';
    IP_DEST_HOST_UNREACHABLE: Result := 'IP_DEST_HOST_UNREACHABLE';
    IP_DEST_PROT_UNREACHABLE: Result := 'IP_DEST_PROT_UNREACHABLE';
    IP_DEST_PORT_UNREACHABLE: Result := 'IP_DEST_PORT_UNREACHABLE';
    IP_NO_RESOURCES: Result := 'IP_NO_RESOURCES';
    IP_BAD_OPTION: Result := 'IP_BAD_OPTION';
    IP_HW_ERROR: Result := 'IP_HW_ERROR';
    IP_PACKET_TOO_BIG: Result := 'IP_PACKET_TOO_BIG';
    IP_REQ_TIMED_OUT: Result := 'IP_REQ_TIMED_OUT';
    IP_BAD_REQ: Result := 'IP_BAD_REQ';
    IP_BAD_ROUTE: Result := 'IP_BAD_ROUTE';
    IP_TTL_EXPIRED_TRANSIT: Result := 'IP_TTL_EXPIRED_TRANSIT';
    IP_TTL_EXPIRED_REASSEM: Result := 'IP_TTL_EXPIRED_REASSEM';
    IP_PARAM_PROBLEM: Result := 'IP_PARAM_PROBLEM';
    IP_SOURCE_QUENCH: Result := 'IP_SOURCE_QUENCH';
    IP_OPTION_TOO_BIG: Result := 'IP_OPTION_TOO_BIG';
    IP_BAD_DESTINATION: Result := 'IP_BAD_DESTINATION';
    IP_ADDR_DELETED: Result := 'IP_ADDR_DELETED';
    IP_SPEC_MTU_CHANGE: Result := 'IP_SPEC_MTU_CHANGE';
    IP_MTU_CHANGE: Result := 'IP_MTU_CHANGE';
    IP_UNLOAD: Result := 'IP_UNLOAD';
    IP_GENERAL_FAILURE: Result := 'IP_GENERAL_FAILURE';
  else
    Result := '';
  end;
end;

function inet_addr; external 'WSock32.Dll';

end.